home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / os2 / e33el2.zip / emacs / 19.33 / lisp / viper-util.el < prev    next >
Lisp/Scheme  |  1996-08-04  |  44KB  |  1,253 lines
  1. ;;; viper-util.el --- Utilities used by viper.el
  2.  
  3. ;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22.  
  23. ;; Code
  24.  
  25. (require 'ring)
  26.  
  27. ;; Compiler pacifier
  28. (defvar vip-overriding-map)
  29. (defvar pm-color-alist)
  30. (defvar zmacs-region-stays)
  31. (defvar vip-search-face)
  32. (defvar vip-minibuffer-current-face)
  33. (defvar vip-minibuffer-insert-face)
  34. (defvar vip-minibuffer-vi-face)
  35. (defvar vip-minibuffer-emacs-face)
  36. (defvar vip-replace-overlay-face)
  37. (defvar vip-minibuffer-overlay)
  38. (defvar vip-replace-overlay)
  39. (defvar vip-search-overlay)
  40. (defvar vip-replace-overlay-cursor-color)
  41. (defvar vip-intermediate-command)
  42. (defvar vip-use-replace-region-delimiters)
  43. (defvar vip-fast-keyseq-timeout)
  44. (defvar vip-related-files-and-buffers-ring)
  45. ;; end compiler pacifier
  46.  
  47. ;; Is it XEmacs?
  48. (defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version))
  49. ;; Is it Emacs?
  50. (defconst vip-emacs-p (not vip-xemacs-p))
  51. ;; Tell whether we are running as a window application or on a TTY
  52. (defsubst vip-device-type ()
  53.   (if vip-emacs-p
  54.       window-system
  55.     (device-type (selected-device))))
  56. ;; in XEmacs: device-type is tty on tty and stream in batch.
  57. (defun vip-window-display-p ()
  58.   (and (vip-device-type) (not (memq (vip-device-type) '(tty stream)))))
  59.  
  60. (defvar vip-ms-style-os-p (memq system-type '(ms-dos windows-nt windows-95))
  61.   "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95.")
  62. (defvar vip-vms-os-p (memq system-type '(vax-vms axp-vms))
  63.   "Tells if Emacs is running under VMS.")
  64.  
  65. (defvar vip-force-faces nil
  66.   "If t, Viper will think that it is running on a display that supports faces.
  67. This is provided as a temporary relief for users of face-capable displays
  68. that Viper doesn't know about.")
  69.  
  70. (defun vip-has-face-support-p ()
  71.   (cond ((vip-window-display-p))
  72.     (vip-force-faces)
  73.     (vip-emacs-p (memq (vip-device-type) '(pc)))
  74.     (vip-xemacs-p (memq (vip-device-type) '(tty pc)))))
  75.  
  76.  
  77. ;;; Macros
  78.  
  79. (defmacro vip-deflocalvar (var default-value &optional documentation)
  80.   (` (progn
  81.        (defvar (, var) (, default-value)
  82.            (, (format "%s\n\(buffer local\)" documentation)))
  83.        (make-variable-buffer-local '(, var))
  84.      )))
  85.  
  86. (defmacro vip-loop (count body)
  87.   "(vip-loop COUNT BODY) Execute BODY COUNT times."
  88.   (list 'let (list (list 'count count))
  89.     (list 'while '(> count 0)
  90.           body
  91.           '(setq count (1- count))
  92.           )))
  93.  
  94. (defmacro vip-buffer-live-p (buf)
  95.   (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf))))))
  96.   
  97. ;; return buffer-specific macro definition, given a full macro definition
  98. (defmacro vip-kbd-buf-alist (macro-elt)
  99.   (` (nth 1 (, macro-elt))))
  100. ;; get a pair: (curr-buffer . macro-definition)
  101. (defmacro vip-kbd-buf-pair (macro-elt)
  102.   (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt)))))
  103. ;; get macro definition for current buffer
  104. (defmacro vip-kbd-buf-definition (macro-elt)
  105.   (` (cdr (vip-kbd-buf-pair (, macro-elt)))))
  106.   
  107. ;; return mode-specific macro definitions, given a full macro definition
  108. (defmacro vip-kbd-mode-alist (macro-elt)
  109.   (` (nth 2 (, macro-elt))))
  110. ;; get a pair: (major-mode . macro-definition)
  111. (defmacro vip-kbd-mode-pair (macro-elt)
  112.   (` (assoc major-mode (vip-kbd-mode-alist (, macro-elt)))))
  113. ;; get macro definition for the current major mode
  114. (defmacro vip-kbd-mode-definition (macro-elt)
  115.   (` (cdr (vip-kbd-mode-pair (, macro-elt)))))
  116.   
  117. ;; return global macro definition, given a full macro definition
  118. (defmacro vip-kbd-global-pair (macro-elt)
  119.   (` (nth 3 (, macro-elt))))
  120. ;; get global macro definition from an elt of macro-alist
  121. (defmacro vip-kbd-global-definition (macro-elt)
  122.   (` (cdr (vip-kbd-global-pair (, macro-elt)))))
  123.   
  124. ;; last elt of a sequence
  125. (defsubst vip-seq-last-elt (seq)
  126.   (elt seq (1- (length seq))))
  127.   
  128. ;; Check if arg is a valid character for register
  129. ;; TYPE is a list that can contain `letter', `Letter', and `digit'.
  130. ;; Letter means lowercase letters, Letter means uppercase letters, and
  131. ;; digit means digits from 1 to 9.
  132. ;; If TYPE is nil, then down/uppercase letters and digits are allowed.
  133. (defun vip-valid-register (reg &optional type)
  134.   (or type (setq type '(letter Letter digit)))
  135.   (or (if (memq 'letter type)
  136.       (and (<= ?a reg) (<= reg ?z)))
  137.       (if (memq 'digit type)
  138.       (and (<= ?1 reg) (<= reg ?9)))
  139.       (if (memq 'Letter type)
  140.       (and (<= ?A reg) (<= reg ?Z)))
  141.       ))
  142.       
  143. ;; checks if object is a marker, has a buffer, and points to within that buffer
  144. (defun vip-valid-marker (marker)
  145.   (if (and (markerp marker) (marker-buffer marker))
  146.       (let ((buf (marker-buffer marker))
  147.         (pos (marker-position marker)))
  148.     (save-excursion
  149.       (set-buffer buf)
  150.       (and (<= pos (point-max)) (<= (point-min) pos))))))
  151.   
  152.  
  153. (defvar vip-minibuffer-overlay-priority 300)
  154. (defvar vip-replace-overlay-priority 400)
  155. (defvar vip-search-overlay-priority 500)
  156.   
  157.  
  158. ;;; XEmacs support
  159.  
  160. (if vip-xemacs-p
  161.     (progn
  162.       (fset 'vip-read-event (symbol-function 'next-command-event))
  163.       (fset 'vip-make-overlay (symbol-function 'make-extent))
  164.       (fset 'vip-overlay-start (symbol-function 'extent-start-position))
  165.       (fset 'vip-overlay-end (symbol-function 'extent-end-position))
  166.       (fset 'vip-overlay-put (symbol-function 'set-extent-property))
  167.       (fset 'vip-overlay-p (symbol-function 'extentp))
  168.       (fset 'vip-overlay-get (symbol-function 'extent-property))
  169.       (fset 'vip-move-overlay (symbol-function 'set-extent-endpoints))
  170.       (if (vip-window-display-p)
  171.       (fset 'vip-iconify (symbol-function 'iconify-frame)))
  172.       (cond ((vip-has-face-support-p)
  173.          (fset 'vip-get-face (symbol-function 'get-face))
  174.          (fset 'vip-color-defined-p
  175.            (symbol-function 'valid-color-name-p))
  176.          )))
  177.   (fset 'vip-read-event (symbol-function 'read-event))
  178.   (fset 'vip-make-overlay (symbol-function 'make-overlay))
  179.   (fset 'vip-overlay-start (symbol-function 'overlay-start))
  180.   (fset 'vip-overlay-end (symbol-function 'overlay-end))
  181.   (fset 'vip-overlay-put (symbol-function 'overlay-put))
  182.   (fset 'vip-overlay-p (symbol-function 'overlayp))
  183.   (fset 'vip-overlay-get (symbol-function 'overlay-get))
  184.   (fset 'vip-move-overlay (symbol-function 'move-overlay))
  185.   (if (vip-window-display-p)
  186.       (fset 'vip-iconify (symbol-function 'iconify-or-deiconify-frame)))
  187.   (cond ((vip-has-face-support-p)
  188.      (fset 'vip-get-face (symbol-function 'internal-get-face))
  189.      (fset 'vip-color-defined-p (symbol-function 'x-color-defined-p))
  190.      )))
  191.  
  192. (fset 'vip-characterp
  193.       (symbol-function
  194.        (if vip-xemacs-p 'characterp 'integerp)))
  195.  
  196. (defsubst vip-color-display-p ()
  197.   (if vip-emacs-p
  198.       (x-display-color-p)
  199.     (eq (device-class (selected-device)) 'color)))
  200.    
  201. (defsubst vip-get-cursor-color ()
  202.   (if vip-emacs-p
  203.       (cdr (assoc 'cursor-color (frame-parameters)))
  204.     (color-instance-name (frame-property (selected-frame) 'cursor-color))))
  205.   
  206.   
  207. ;; OS/2
  208. (cond ((eq (vip-device-type) 'pm)
  209.        (fset 'vip-color-defined-p
  210.          (function (lambda (color) (assoc color pm-color-alist))))))
  211.     
  212. ;; needed to smooth out the difference between Emacs and XEmacs
  213. (defsubst vip-italicize-face (face)
  214.   (if vip-xemacs-p
  215.       (make-face-italic face)
  216.     (make-face-italic face nil 'noerror)))
  217.     
  218. ;; test if display is color and the colors are defined
  219. (defsubst vip-can-use-colors (&rest color